home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 3 / adb / g-os_lib < prev    next >
Text File  |  1996-02-12  |  13KB  |  430 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                          G N A T . O S _ L I B                           --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.31 $                             --
  10. --                                                                          --
  11. --   Copyright (C) 1992,1993,1994,1995,1996 Free Software Foundation, Inc.  --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with Unchecked_Conversion;
  37. with System;                  use System;
  38. with System.Storage_Elements; use System.Storage_Elements;
  39.  
  40. package body GNAT.OS_Lib is
  41.  
  42.    -----------------------
  43.    -- Local Subprograms --
  44.    -----------------------
  45.  
  46.    function C_String_Length (S : Address) return Integer;
  47.    --  Returns the length of a C string.  Does check for null address
  48.    --  (returns 0).
  49.  
  50.    ---------------------
  51.    -- C_String_Length --
  52.    ---------------------
  53.  
  54.    function C_String_Length (S : Address) return Integer is
  55.       function Strlen (S : Address) return Integer;
  56.       pragma Import (C, Strlen, "strlen");
  57.  
  58.    begin
  59.       if S = Null_Address then
  60.          return 0;
  61.       else
  62.          return Strlen (S);
  63.       end if;
  64.    end C_String_Length;
  65.  
  66.    ----------------------
  67.    -- Create_Temp_File --
  68.    ----------------------
  69.  
  70.    procedure Create_Temp_File
  71.      (FD   : out File_Descriptor;
  72.       Name : out Temp_File_Name)
  73.    is
  74.       function Get_Temp_Name (T : Address) return Address;
  75.       pragma Import (C, Get_Temp_Name, "mktemp");
  76.  
  77.    begin
  78.       Name := "GNAT-XXXXXX" & Ascii.NUL;
  79.  
  80.       --  Check for NULL pointer returned by C
  81.  
  82.       if Get_Temp_Name (Name'Address) = To_Address (0) then
  83.          FD := -1;
  84.       else
  85.          FD := Create_New_File (Name'Address, Binary);
  86.       end if;
  87.    end Create_Temp_File;
  88.  
  89.    -----------------
  90.    -- Delete_File --
  91.    -----------------
  92.  
  93.    procedure Delete_File (Name : Address; Success : out Boolean) is
  94.       R : Integer;
  95.  
  96.       function unlink (A : Address) return Integer;
  97.       pragma Import (C, unlink, "unlink");
  98.  
  99.    begin
  100.       R := unlink (Name);
  101.       Success := (R = 0);
  102.    end Delete_File;
  103.  
  104.    ----------------------
  105.    -- File_Time_Stamp  --
  106.    ----------------------
  107.  
  108.    function File_Time_Stamp (FD : File_Descriptor) return OS_Time is
  109.       function File_Time (FD    : File_Descriptor) return OS_Time;
  110.       pragma Import (C, File_Time, "file_time_fd");
  111.  
  112.    begin
  113.       return File_Time (FD);
  114.    end File_Time_Stamp;
  115.  
  116.    ----------------------
  117.    -- File_Time_Stamp  --
  118.    ----------------------
  119.  
  120.    function File_Time_Stamp (Name : String) return OS_Time is
  121.  
  122.       function File_Time (Name : Address) return OS_Time;
  123.       pragma Import (C, File_Time, "file_time_name");
  124.  
  125.       F_Name : String (1 .. Name'Length + 1);
  126.  
  127.    begin
  128.       F_Name (1 .. Name'Length) := Name;
  129.       F_Name (Name'Length + 1)  := Ascii.NUL;
  130.       return File_Time (F_Name'Address);
  131.    end File_Time_Stamp;
  132.  
  133.    ------------
  134.    -- Getenv --
  135.    ------------
  136.  
  137.    function Getenv (Name : String) return String_Access is
  138.  
  139.       procedure Get_Env_Value_Ptr (Name, Length, Ptr : Address);
  140.       pragma Import (C, Get_Env_Value_Ptr, "get_env_value_ptr");
  141.  
  142.       procedure Strncpy (Astring_Addr, Cstring : Address; N : Integer);
  143.       pragma Import (C, Strncpy, "strncpy");
  144.  
  145.       Env_Value_Ptr    : Address;
  146.       Env_Value_Length : Integer;
  147.       F_Name           : String (1 .. Name'Length + 1);
  148.       Result           : String_Access;
  149.  
  150.    begin
  151.       F_Name (1 .. Name'Length) := Name;
  152.       F_Name (Name'Length + 1)  := Ascii.NUL;
  153.  
  154.       Get_Env_Value_Ptr
  155.         (F_Name'Address, Env_Value_Length'Address, Env_Value_Ptr'Address);
  156.  
  157.       Result := new String (1 .. Env_Value_Length);
  158.  
  159.       if Env_Value_Length > 0 then
  160.          Strncpy (Result.all'Address, Env_Value_Ptr, Env_Value_Length);
  161.       end if;
  162.  
  163.       return Result;
  164.    end Getenv;
  165.  
  166.    ------------
  167.    -- GM_Day --
  168.    ------------
  169.  
  170.    function GM_Day (Date : OS_Time) return Day_Type is
  171.       Y  : Year_Type;
  172.       Mo : Month_Type;
  173.       D  : Day_Type;
  174.       H  : Hour_Type;
  175.       Mn : Minute_Type;
  176.       S  : Second_Type;
  177.  
  178.    begin
  179.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  180.       return D;
  181.    end GM_Day;
  182.  
  183.    -------------
  184.    -- GM_Hour --
  185.    -------------
  186.  
  187.    function GM_Hour (Date : OS_Time) return Hour_Type is
  188.       Y  : Year_Type;
  189.       Mo : Month_Type;
  190.       D  : Day_Type;
  191.       H  : Hour_Type;
  192.       Mn : Minute_Type;
  193.       S  : Second_Type;
  194.  
  195.    begin
  196.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  197.       return H;
  198.    end GM_Hour;
  199.  
  200.    ---------------
  201.    -- GM_Minute --
  202.    ---------------
  203.  
  204.    function GM_Minute (Date : OS_Time) return Minute_Type is
  205.       Y  : Year_Type;
  206.       Mo : Month_Type;
  207.       D  : Day_Type;
  208.       H  : Hour_Type;
  209.       Mn : Minute_Type;
  210.       S  : Second_Type;
  211.  
  212.    begin
  213.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  214.       return Mn;
  215.    end GM_Minute;
  216.  
  217.    --------------
  218.    -- GM_Month --
  219.    --------------
  220.  
  221.    function GM_Month (Date : OS_Time) return Month_Type is
  222.       Y  : Year_Type;
  223.       Mo : Month_Type;
  224.       D  : Day_Type;
  225.       H  : Hour_Type;
  226.       Mn : Minute_Type;
  227.       S  : Second_Type;
  228.  
  229.    begin
  230.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  231.       return Mo;
  232.    end GM_Month;
  233.  
  234.    ---------------
  235.    -- GM_Second --
  236.    ---------------
  237.  
  238.    function GM_Second (Date : OS_Time) return Second_Type is
  239.       Y  : Year_Type;
  240.       Mo : Month_Type;
  241.       D  : Day_Type;
  242.       H  : Hour_Type;
  243.       Mn : Minute_Type;
  244.       S  : Second_Type;
  245.  
  246.    begin
  247.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  248.       return S;
  249.    end GM_Second;
  250.  
  251.    --------------
  252.    -- GM_Split --
  253.    --------------
  254.  
  255.    procedure GM_Split
  256.      (Date   : OS_Time;
  257.       Year   : out Year_Type;
  258.       Month  : out Month_Type;
  259.       Day    : out Day_Type;
  260.       Hour   : out Hour_Type;
  261.       Minute : out Minute_Type;
  262.       Second : out Second_Type)
  263.    is
  264.       procedure To_GM_Time
  265.         (P_Time_T, P_Year, P_Month, P_Day, P_Hours, P_Mins, P_Secs : Address);
  266.       pragma Import (C, To_GM_Time, "to_gm_time");
  267.  
  268.       T  : OS_Time := Date;
  269.       Y  : Integer;
  270.       Mo : Integer;
  271.       D  : Integer;
  272.       H  : Integer;
  273.       Mn : Integer;
  274.       S  : Integer;
  275.  
  276.    begin
  277.       To_GM_Time (T'Address, Y'Address, Mo'Address, D'Address, H'Address,
  278.                   Mn'Address, S'Address);
  279.       Year   := Y + 1900;
  280.       Month  := Mo + 1;
  281.       Day    := D;
  282.       Hour   := H;
  283.       Minute := Mn;
  284.       Second := S;
  285.    end GM_Split;
  286.  
  287.    -------------
  288.    -- GM_Year --
  289.    -------------
  290.  
  291.    function GM_Year (Date : OS_Time) return Year_Type is
  292.       Y  : Year_Type;
  293.       Mo : Month_Type;
  294.       D  : Day_Type;
  295.       H  : Hour_Type;
  296.       Mn : Minute_Type;
  297.       S  : Second_Type;
  298.  
  299.    begin
  300.       GM_Split (Date, Y, Mo, D, H, Mn, S);
  301.       return Y;
  302.    end GM_Year;
  303.  
  304.    ------------------
  305.    -- Is_Directory --
  306.    ------------------
  307.  
  308.    function Is_Directory (Name : String) return Boolean is
  309.  
  310.       function Is_Directory (Name : Address) return Integer;
  311.       pragma Import (C, Is_Directory, "is_directory");
  312.  
  313.       F_Name : String (1 .. Name'Length + 1);
  314.  
  315.    begin
  316.       F_Name (1 .. Name'Length) := Name;
  317.       F_Name (Name'Length + 1)  := Ascii.NUL;
  318.       return Is_Directory (F_Name'Address) /= 0;
  319.    end Is_Directory;
  320.  
  321.    ---------------------
  322.    -- Is_Regular_File --
  323.    ---------------------
  324.  
  325.    function Is_Regular_File (Name : String) return Boolean is
  326.  
  327.       function Is_Regular_File (Name : Address) return Integer;
  328.       pragma Import (C, Is_Regular_File, "is_regular_file");
  329.  
  330.       F_Name : String (1 .. Name'Length + 1);
  331.  
  332.    begin
  333.       F_Name (1 .. Name'Length) := Name;
  334.       F_Name (Name'Length + 1)  := Ascii.NUL;
  335.       return Is_Regular_File (F_Name'Address) /= 0;
  336.    end Is_Regular_File;
  337.  
  338.    -------------------------
  339.    -- Locate_Regular_File --
  340.    -------------------------
  341.  
  342.    function Locate_Regular_File
  343.      (File_Name : String;
  344.       Path      : String)
  345.       return      String_Access
  346.    is
  347.       function Locate_Exec (Exec_Name, Path_Val : Address) return Address;
  348.       pragma Import (C, Locate_Exec, "locate_exec");
  349.  
  350.       --  "historical reasons" for the name of the C function. ???
  351.  
  352.       Exec_Name  : String (1 .. File_Name'Length + 1);
  353.       Path_Val   : String (1 .. Path'Length + 1);
  354.       Path_Addr  : Address;
  355.       Path_Len   : Integer;
  356.       Return_Val : String_Access;
  357.  
  358.    begin
  359.       Exec_Name (1 .. File_Name'Length) := File_Name;
  360.       Exec_Name (Exec_Name'Last)        := Ascii.NUL;
  361.       Path_Val  (1 .. Path'Length)      := Path;
  362.       Path_Val  (Path_Val'Last)         := Ascii.NUL;
  363.  
  364.       Path_Addr := Locate_Exec (Exec_Name'Address, Path_Val'Address);
  365.       Path_Len  := C_String_Length (Path_Addr);
  366.  
  367.       if Path_Len = 0 then
  368.          return null;
  369.       else
  370.          Return_Val := new String (1 .. Path_Len);
  371.  
  372.          declare
  373.             subtype Path_String is String (1 .. Path_Len);
  374.             type    Path_String_Access is access Path_String;
  375.             function Address_To_Access is new
  376.               Unchecked_Conversion (Source => Address,
  377.                                     Target => Path_String_Access);
  378.             Path_Access : Path_String_Access := Address_To_Access (Path_Addr);
  379.  
  380.          begin
  381.             for J in 1 .. Path_Len loop
  382.                Return_Val (J) := Path_Access (J);
  383.             end loop;
  384.  
  385.             return Return_Val;
  386.          end;
  387.       end if;
  388.    end Locate_Regular_File;
  389.  
  390.    -----------
  391.    -- Spawn --
  392.    -----------
  393.  
  394.    procedure Spawn
  395.      (Program_Name : String;
  396.       Args         : Argument_List;
  397.       Success      : out Boolean)
  398.    is
  399.       Arg_List : array (1 .. Args'Length + 2) of Address;
  400.  
  401.       Arg : String_Access;
  402.  
  403.       function Portable_Spawn (Args : Address) return Integer;
  404.       pragma Import (C, Portable_Spawn, "portable_spawn");
  405.  
  406.    begin
  407.       Arg := new String (1 .. Program_Name'Length + 1);
  408.       Arg (1 .. Program_Name'Length) := Program_Name;
  409.       Arg (Arg'Last)                 := Ascii.NUL;
  410.       Arg_List (1)                   := Arg.all'Address;
  411.  
  412.       for J in 1 .. Args'Length loop
  413.          Arg := new String (1 .. Args (J + Args'First - 1)'Length + 1);
  414.          Arg (1 .. Arg'Last - 1) := Args (J + Args'First - 1).all;
  415.          Arg (Arg'Last) := Ascii.NUL;
  416.          Arg_List (J + 1) := Arg.all'Address;
  417.       end loop;
  418.  
  419.       Arg_List (Arg_List'Last) := Null_Address;
  420.  
  421.       if Portable_Spawn (Arg_List'Address) = 0 then
  422.          Success := True;
  423.       else
  424.          Success := False;
  425.       end if;
  426.  
  427.    end Spawn;
  428.  
  429. end GNAT.OS_Lib;
  430.